home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xldmem.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  22.0 KB  |  953 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xldmem.c
  5. * RCS:          $Header: xldmem.c,v 1.8 91/03/24 22:24:34 mayer Exp $
  6. * Description:  xlisp dynamic memory management routines.
  7. * Author:       David Michael Betz; Niels Mayer
  8. * Created:      
  9. * Modified:     Fri Oct  4 03:36:28 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xldmem.c,v 1.8 91/03/24 22:24:34 mayer Exp $";
  43.  
  44.  
  45. #include "xlisp.h"
  46.  
  47. /* node flags */
  48. #define MARK    1
  49. #define LEFT    2
  50.  
  51. /* macro to compute the size of a segment */
  52. #define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
  53.  
  54. /* external variables */
  55. extern LVAL obarray,s_gcflag,s_gchook,s_unbound,true;
  56. extern LVAL xlenv,xlfenv,xldenv;
  57. extern char buf[];
  58.  
  59. /* variables local to xldmem.c and xlimage.c */
  60. SEGMENT *segs,*lastseg,*fixseg,*charseg;
  61. int anodes,nsegs,gccalls;
  62. long nnodes,nfree,total;
  63. LVAL fnodes;
  64.  
  65. /* external procedures */
  66. extern char *malloc();
  67. extern char *calloc();
  68.  
  69. /* forward declarations */
  70. LOCAL FORWARD LVAL newnode();    /* NPM: changed this to LOCAL */
  71. LOCAL FORWARD unsigned char *stralloc(); /* NPM: changed this to LOCAL */
  72. FORWARD SEGMENT *newsegment();
  73.  
  74. #if (defined(UNIX) || defined(WINTERP))
  75. /* cv_pipe - allocate and initialize a new XLTYPE_PIPE node, which uses same node structure as STREAM (see cvfile())  */
  76. LVAL cv_pipe(fp)
  77.      FILE *fp;
  78. {
  79.   LVAL val;
  80.   val = newnode(XLTYPE_PIPE);
  81.   setfile(val,fp);
  82.   setsavech(val,'\0');
  83.   return (val);
  84. }
  85. #endif /* (defined(UNIX) || defined(WINTERP)) */
  86.  
  87. #ifdef WINTERP
  88.  
  89. extern LVAL v_savedobjs;
  90. extern void Wxms_Garbage_Collect_XmString(); /* w_XmString.c */
  91. extern void Wpm_Decr_Refcount_Or_Free_Pixmap();    /* w_pixmap.c */
  92. extern void Wcls_Garbage_Collect_WIDGETOBJ(); /* w_classes.c */
  93.  
  94. /* cv_xtresource - convert a xtresource instance to an XLTYPE_XT_RESOURCE node */
  95. LVAL cv_xtresource(res)
  96.      struct _Resource_Instance *res;
  97. {
  98.   LVAL val;
  99.   val = newnode(XLTYPE_XT_RESOURCE);
  100.   val->n_xtresource = res;
  101.   return (val);
  102. }
  103.  
  104. /* cv_pixel - convert a Pixel to an XLTYPE_Pixel node */
  105. LVAL cv_pixel(pixel)
  106.      Pixel pixel;
  107. {
  108.   LVAL val;
  109.   val = newnode(XLTYPE_Pixel);
  110.   val->n_pixel = pixel;
  111.   return (val);
  112. }
  113.  
  114. /* cv_pixmap - allocate and initialize a new XLTYPE_Pixmap node */
  115. LVAL cv_pixmap(pixmap)
  116.      Pixmap pixmap;
  117. {
  118.   LVAL val;
  119.   val = newnode(XLTYPE_Pixmap);
  120.   val->n_pixmap = pixmap;
  121.   return (val);
  122. }
  123.  
  124. /* cv_ximage -- allocate and initialize a new XLTYPE_XImage node */
  125. LVAL cv_ximage(ximage)
  126.      XImage *ximage;
  127. {
  128.   LVAL val;
  129.   val = newnode(XLTYPE_XImage);
  130.   val->n_ximage = ximage;
  131.   return (val);
  132. }
  133.  
  134. /* cv_xmstring -- allocate and initialize a new XLTYPE_XmString node */
  135. LVAL cv_xmstring(xmstr)
  136.      XmString xmstr;
  137. {
  138.   LVAL val;
  139.   val = newnode(XLTYPE_XmString);
  140.   val->n_xmstring = xmstr;
  141.   return (val);
  142. }
  143.  
  144. /* cv_xevent_ptr -- allocate and initialize a new XLTYPE_XEvent node */
  145. LVAL cv_xevent(xevp)
  146.      XEvent *xevp;
  147. {
  148.   LVAL val;
  149.   val = newnode(XLTYPE_XEvent);
  150.   val->n_xevent = xevp;
  151.   return (val);
  152. }
  153.  
  154. /* cv_window -- allocate and initialize a new XLTYPE_Window node */
  155. LVAL cv_window(win)
  156.      Window win;
  157. {
  158.   LVAL val;
  159.   val = newnode(XLTYPE_Window);
  160.   val->n_window = win;
  161.   return (val);
  162. }
  163.  
  164. /* cv_xtaccelerators -- allocate and initialize a new XLTYPE_XtAccelerators node */
  165. LVAL cv_xtaccelerators(axl)
  166.      XtAccelerators axl;
  167. {
  168.   LVAL val;
  169.   val = newnode(XLTYPE_XtAccelerators);
  170.   val->n_xtaccelerators = axl;
  171.   return (val);
  172. }
  173.  
  174. /* cv_xttranslations -- allocate and initialize a new XLTYPE_XtTranslations node */
  175. LVAL cv_xttranslations(txl)
  176.      XtTranslations txl;
  177. {
  178.   LVAL val;
  179.   val = newnode(XLTYPE_XtTranslations);
  180.   val->n_xttranslations = txl;
  181.   return (val);
  182. }
  183.  
  184. /* cv_string - allocate and initialize a new STRING node.     */
  185. /* WARNING: use cvstring() to make a copy of the string ...   */
  186. /* the string passed will get freed during garbage collection */
  187. LVAL cv_string(str)
  188.      char* str;
  189. {
  190.   LVAL val;
  191.   val = newnode(STRING);
  192.   val->n_strlen = strlen(str) + 1;
  193.   val->n_string = (unsigned char*) str;
  194.   return (val);
  195. }
  196.  
  197. /* new_pixrefobj() -- allocate and initialize a new XLTYPE_PIXMAP_REFOBJ */
  198. LVAL new_pixrefobj()
  199. {
  200.   LVAL val;
  201.   val = newvector(PIXMAP_REFOBJ_SIZE);
  202.   val->n_type = XLTYPE_PIXMAP_REFOBJ;
  203.   return (val);
  204. }
  205.  
  206. /* new_callbackobj() -- allocate and initialize a new XLTYPE_CALLBACKOBJ */
  207. LVAL new_callbackobj()
  208. {
  209.   LVAL val;
  210.   val = newvector(CALLBACKOBJ_SIZE);
  211.   val->n_type = XLTYPE_CALLBACKOBJ;
  212.   return (val);
  213. }
  214.  
  215. /* new_timeoutobj() -- allocate and initialize a new XLTYPE_TIMEOUTOBJ */
  216. LVAL new_timeoutobj()
  217. {
  218.   LVAL val;
  219.   val = newvector(TIMEOUTOBJ_SIZE);
  220.   val->n_type = XLTYPE_TIMEOUTOBJ;
  221.   return (val);
  222. }
  223.  
  224. /* new_evhandlerobj() -- allocate and initialize a new XLTYPE_EVHANDLEROBJ */
  225. LVAL new_evhandlerobj()
  226. {
  227.   LVAL val;
  228.   val = newvector(EVHANDLEROBJ_SIZE);
  229.   val->n_type = XLTYPE_EVHANDLEROBJ;
  230.   return (val);
  231. }
  232.  
  233. #endif                /* WINTERP */
  234.  
  235. /* cons - construct a new cons node */
  236. LVAL cons(x,y)
  237.   LVAL x,y;
  238. {
  239.     LVAL nnode;
  240.  
  241.     /* get a free node */
  242.     if ((nnode = fnodes) == NIL) {
  243.     xlstkcheck(2);
  244.     xlprotect(x);
  245.     xlprotect(y);
  246.     findmem();
  247.     if ((nnode = fnodes) == NIL)
  248.         xlabort("insufficient node space");
  249.     xlpop();
  250.     xlpop();
  251.     }
  252.  
  253.     /* unlink the node from the free list */
  254.     fnodes = cdr(nnode);
  255.     --nfree;
  256.  
  257.     /* initialize the new node */
  258.     nnode->n_type = CONS;
  259.     rplaca(nnode,x);
  260.     rplacd(nnode,y);
  261.  
  262.     /* return the new node */
  263.     return (nnode);
  264. }
  265.  
  266. /* cvstring - convert a string to a string node */
  267. LVAL cvstring(str)
  268.   char *str;
  269. {
  270.     LVAL val;
  271.     xlsave1(val);
  272.     val = newnode(STRING);
  273.     val->n_strlen = strlen(str) + 1;
  274.     val->n_string = stralloc(getslength(val));
  275.     strcpy(getstring(val),str);
  276.     xlpop();
  277.     return (val);
  278. }
  279.  
  280. /* newstring - allocate and initialize a new string */
  281. LVAL newstring(size)
  282.   int size;
  283. {
  284.     LVAL val;
  285.     xlsave1(val);
  286.     val = newnode(STRING);
  287.     val->n_strlen = size;
  288.     val->n_string = stralloc(getslength(val));
  289.     strcpy(getstring(val),"");
  290.     xlpop();
  291.     return (val);
  292. }
  293.  
  294. /* cvsymbol - convert a string to a symbol */
  295. LVAL cvsymbol(pname)
  296.   char *pname;
  297. {
  298.     LVAL val;
  299.     xlsave1(val);
  300.     val = newvector(SYMSIZE);
  301.     val->n_type = SYMBOL;
  302.     setvalue(val,s_unbound);
  303.     setfunction(val,s_unbound);
  304.     setpname(val,cvstring(pname));
  305.     xlpop();
  306.     return (val);
  307. }
  308.  
  309. /* cvsubr - convert a function to a subr or fsubr */
  310. LVAL cvsubr(fcn,type,offset)
  311.   LVAL (*fcn)(); int type,offset;
  312. {
  313.     LVAL val;
  314.     val = newnode(type);
  315.     val->n_subr = fcn;
  316.     val->n_offset = offset;
  317.     return (val);
  318. }
  319.  
  320. /* cvfile - convert a file pointer to a stream */
  321. LVAL cvfile(fp)
  322.   FILE *fp;
  323. {
  324.     LVAL val;
  325.     val = newnode(STREAM);
  326.     setfile(val,fp);
  327.     setsavech(val,'\0');
  328.     return (val);
  329. }
  330.  
  331. /* cvfixnum - convert an integer to a fixnum node */
  332. LVAL cvfixnum(n)
  333.   FIXTYPE n;
  334. {
  335.     LVAL val;
  336.     if (n >= SFIXMIN && n <= SFIXMAX)
  337.     return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
  338.     val = newnode(FIXNUM);
  339.     val->n_fixnum = n;
  340.     return (val);
  341. }
  342.  
  343. /* cvflonum - convert a floating point number to a flonum node */
  344. LVAL cvflonum(n)
  345.   FLOTYPE n;
  346. {
  347.     LVAL val;
  348.     val = newnode(FLONUM);
  349.     val->n_flonum = n;
  350.     return (val);
  351. }
  352.  
  353. /* cvchar - convert an integer to a character node */
  354. LVAL cvchar(n)
  355.   int n;
  356. {
  357.     if (n >= CHARMIN && n <= CHARMAX)
  358.     return (&charseg->sg_nodes[n-CHARMIN]);
  359.     xlerror("character code out of range",cvfixnum((FIXTYPE)n));
  360. }
  361.  
  362. /* newustream - create a new unnamed stream */
  363. LVAL newustream()
  364. {
  365.     LVAL val;
  366.     val = newnode(USTREAM);
  367.     sethead(val,NIL);
  368.     settail(val,NIL);
  369.     return (val);
  370. }
  371.  
  372. /* newobject - allocate and initialize a new object */
  373. LVAL newobject(cls,size)
  374.   LVAL cls; int size;
  375. {
  376.     LVAL val;
  377.     val = newvector(size+1);
  378.     val->n_type = OBJECT;
  379.     setelement(val,0,cls);
  380.     return (val);
  381. }
  382.  
  383. /* newclosure - allocate and initialize a new closure */
  384. LVAL newclosure(name,type,env,fenv)
  385.   LVAL name,type,env,fenv;
  386. {
  387.     LVAL val;
  388.     val = newvector(CLOSIZE);
  389.     val->n_type = CLOSURE;
  390.     setname(val,name);
  391.     settype(val,type);
  392.     setenv(val,env);
  393.     setfenv(val,fenv);
  394.     return (val);
  395. }
  396.  
  397. /* newstruct - allocate and initialize a new structure node */
  398. LVAL newstruct(type,size)
  399.   LVAL type; int size;
  400. {
  401.     LVAL val;
  402.     val = newvector(size+1);
  403.     val->n_type = STRUCT;
  404.     setelement(val,0,type);
  405.     return (val);
  406. }
  407.  
  408. /* newvector - allocate and initialize a new vector node */
  409. LVAL newvector(size)
  410.   int size;
  411. {
  412.     LVAL vect;
  413.     int bsize;
  414.     xlsave1(vect);
  415.     vect = newnode(VECTOR);
  416.     vect->n_vsize = 0;
  417.     if (bsize = size * sizeof(LVAL)) {
  418.     if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) {
  419.         findmem();
  420.         if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL)
  421.         xlfail("insufficient vector space");
  422.     }
  423.     vect->n_vsize = size;
  424.     total += (long) bsize;
  425.     }
  426.     xlpop();
  427.     return (vect);
  428. }
  429.  
  430. /* newnode - allocate a new node */
  431. LOCAL LVAL newnode(type)
  432.   int type;
  433. {
  434.     LVAL nnode;
  435.  
  436.     /* get a free node */
  437.     if ((nnode = fnodes) == NIL) {
  438.     findmem();
  439.     if ((nnode = fnodes) == NIL)
  440.         xlabort("insufficient node space");
  441.     }
  442.  
  443.     /* unlink the node from the free list */
  444.     fnodes = cdr(nnode);
  445.     nfree -= 1L;
  446.  
  447.     /* initialize the new node */
  448.     nnode->n_type = type;
  449.     rplacd(nnode,NIL);
  450.  
  451.     /* return the new node */
  452.     return (nnode);
  453. }
  454.  
  455. /* stralloc - allocate memory for a string adding a byte for the terminator */
  456. LOCAL unsigned char *stralloc(size)
  457.   int size;
  458. {
  459.     unsigned char *sptr;
  460.  
  461.     /* allocate memory for the string copy */
  462.     if ((sptr = (unsigned char *)malloc(size)) == NULL) {
  463.     gc();  
  464.     if ((sptr = (unsigned char *)malloc(size)) == NULL)
  465.         xlfail("insufficient string space");
  466.     }
  467.     total += (long)size;
  468.  
  469.     /* return the new string memory */
  470.     return (sptr);
  471. }
  472.  
  473. /* findmem - find more memory by collecting then expanding */
  474. LOCAL findmem()
  475. {
  476.     gc();
  477.     if (nfree < (long)anodes)
  478.     addseg();
  479. }
  480.  
  481. /* gc - garbage collect (only called here and in xlimage.c) */
  482. gc()
  483. {
  484.     register LVAL **p,*ap,tmp;
  485.     char buf[STRMAX+1];
  486.     LVAL *newfp,fun;
  487.  
  488.     /* print the start of the gc message */
  489.     if (s_gcflag && getvalue(s_gcflag)) {
  490.     sprintf(buf,"[ gc: total %ld, ",nnodes);
  491.     stdputstr(buf);
  492.     }
  493.  
  494. #ifdef WINTERP
  495.     /* mark the callback-obj's, timeout-obj's, etc that are "referenced"
  496.        inside Motif/Xtoolkit implementation. */
  497.     if (v_savedobjs)
  498.         mark(v_savedobjs);
  499. #endif
  500.  
  501.     /* mark the obarray, the argument list and the current environment */
  502.     if (obarray)
  503.     mark(obarray);
  504.     if (xlenv)
  505.     mark(xlenv);
  506.     if (xlfenv)
  507.     mark(xlfenv);
  508.     if (xldenv)
  509.     mark(xldenv);
  510.  
  511.     /* mark the evaluation stack */
  512.     for (p = xlstack; p < xlstktop; ++p)
  513.     if (tmp = **p)
  514.         mark(tmp);
  515.  
  516.     /* mark the argument stack */
  517.     for (ap = xlargstkbase; ap < xlsp; ++ap)
  518.     if (tmp = *ap)
  519.         mark(tmp);
  520.  
  521.     /* sweep memory collecting all unmarked nodes */
  522.     sweep();
  523.  
  524.     /* count the gc call */
  525.     ++gccalls;
  526.  
  527.     /* call the *gc-hook* if necessary */
  528.     if (s_gchook && (fun = getvalue(s_gchook))) {
  529.     newfp = xlsp;
  530.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  531.     pusharg(fun);
  532.     pusharg(cvfixnum((FIXTYPE)2));
  533.     pusharg(cvfixnum((FIXTYPE)nnodes));
  534.     pusharg(cvfixnum((FIXTYPE)nfree));
  535.     xlfp = newfp;
  536.     xlapply(2);
  537.     }
  538.  
  539.     /* print the end of the gc message */
  540.     if (s_gcflag && getvalue(s_gcflag)) {
  541.     sprintf(buf,"%ld free ]\n",nfree);
  542.     stdputstr(buf);
  543.     }
  544. }
  545.  
  546. /* mark - mark all accessible nodes */
  547. LOCAL mark(ptr)
  548.   LVAL ptr;
  549. {
  550.     register LVAL this,prev,tmp;
  551.     int type,i,n;
  552.  
  553.     /* initialize */
  554.     prev = NIL;
  555.     this = ptr;
  556.  
  557.     /* mark this list */
  558.     for (;;) {
  559.  
  560.     /* descend as far as we can */
  561.     while (!(this->n_flags & MARK))
  562.  
  563.         /* check cons and unnamed stream nodes */
  564.         if ((type = ntype(this)) == CONS || type == USTREAM) {
  565.         if (tmp = car(this)) {
  566.             this->n_flags |= MARK|LEFT;
  567.             rplaca(this,prev);
  568.         }
  569.         else if (tmp = cdr(this)) {
  570.             this->n_flags |= MARK;
  571.             rplacd(this,prev);
  572.         }
  573.         else {                /* both sides nil */
  574.             this->n_flags |= MARK;
  575.             break;
  576.         }
  577.         prev = this;            /* step down the branch */
  578.         this = tmp;
  579.         }
  580.  
  581.         /* mark other node types */
  582.         else {
  583.         this->n_flags |= MARK;
  584.         switch (type) {
  585. #ifdef WINTERP
  586.         case XLTYPE_WIDGETOBJ:
  587.           /* 
  588.            * An XLTYPE_WIDGETOBJ is just like a OBJECT node with slot 0
  589.            * being the class, and the other slots being instance
  590.            * variables. class WIDGET_CLASS defines a special instance
  591.            * variable at slot 1 holding the WidgetID. Since that slot
  592.            * isn't an LVAL, it should not be mark()'d. Any additional
  593.            * slots means that the WIDGETOBJ was subclassed and new
  594.            * instance variables were added in the subclass which need to
  595.            * be marked.
  596.            */
  597.           if (tmp = getelement(this, 0))
  598.             mark(tmp);
  599.           /* HACK: skip element 1 since it's special, start at 2 */
  600.           for (i = 2, n = getsize(this) - 2; --n >= 0; ++i)
  601.             if ((tmp = getelement(this,i)))
  602.               mark(tmp);
  603.           break;
  604.         case XLTYPE_TIMEOUTOBJ:
  605.         case XLTYPE_CALLBACKOBJ:
  606.         case XLTYPE_PIXMAP_REFOBJ:
  607.         case XLTYPE_EVHANDLEROBJ:
  608. #endif
  609.         case SYMBOL:
  610.         case OBJECT:
  611.         case VECTOR:
  612.         case CLOSURE:
  613.         case STRUCT:
  614.             for (i = 0, n = getsize(this); --n >= 0; ++i)
  615.             if (tmp = getelement(this,i))
  616.                 mark(tmp);
  617.             break;
  618.         }
  619.         break;
  620.         }
  621.  
  622.     /* backup to a point where we can continue descending */
  623.     for (;;)
  624.  
  625.         /* make sure there is a previous node */
  626.         if (prev) {
  627.         if (prev->n_flags & LEFT) {    /* came from left side */
  628.             prev->n_flags &= ~LEFT;
  629.             tmp = car(prev);
  630.             rplaca(prev,this);
  631.             if (this = cdr(prev)) {
  632.             rplacd(prev,tmp);            
  633.             break;
  634.             }
  635.         }
  636.         else {                /* came from right side */
  637.             tmp = cdr(prev);
  638.             rplacd(prev,this);
  639.         }
  640.         this = prev;            /* step back up the branch */
  641.         prev = tmp;
  642.         }
  643.  
  644.         /* no previous node, must be done */
  645.         else
  646.         return;
  647.     }
  648. }
  649.  
  650. /* sweep - sweep all unmarked nodes and add them to the free list */
  651. LOCAL sweep()
  652. {
  653.     SEGMENT *seg;
  654.     LVAL p;
  655.     int n;
  656.  
  657.     /* empty the free list */
  658.     fnodes = NIL;
  659.     nfree = 0L;
  660.  
  661.     /* add all unmarked nodes */
  662.     for (seg = segs; seg; seg = seg->sg_next) {
  663.     if (seg == fixseg)     /* don't sweep the fixnum segment */
  664.         continue;
  665.     else if (seg == charseg) /* don't sweep the character segment */
  666.         continue;
  667.     p = &seg->sg_nodes[0];
  668.     for (n = seg->sg_size; --n >= 0; ++p)
  669.         if (!(p->n_flags & MARK)) {
  670.         switch (ntype(p)) {
  671.         case STRING:
  672.             if (getstring(p) != NULL) {
  673.                 total -= (long)getslength(p);
  674.                 free(getstring(p));
  675.             }
  676.             break;
  677.         case STREAM:
  678.             if (getfile(p))
  679.                 osclose(getfile(p));
  680.             break;
  681. #if (defined(UNIX) || defined(WINTERP))
  682.         case XLTYPE_PIPE: /* same as STREAM, except that pipes must be closed w/ pclose() */
  683.             if (getfile(p))
  684.                 pclose(getfile(p));    
  685.             break;
  686. #endif /* (defined(UNIX) || defined(WINTERP)) */
  687. #ifdef WINTERP
  688.         case XLTYPE_XmString:
  689.             Wxms_Garbage_Collect_XmString(p);
  690.             break;
  691.         case XLTYPE_Pixmap:
  692.             Wpm_Decr_Refcount_Or_Free_Pixmap(p); /* Tell Motif that the X11 Pixmap is no longer ref'd */
  693.             break;
  694.                 case XLTYPE_WIDGETOBJ:
  695.             /* During initialization (:isnew method), we stored
  696.                a pointer to WIDGETOBJ in the XmNuserData
  697.                resource. We must clear this since it will be
  698.                invalid after the WIDGETOBJ is garbage colected */
  699.             Wcls_Garbage_Collect_WIDGETOBJ(p);
  700.                 /* fall through to "VECTOR" case */
  701.             case XLTYPE_TIMEOUTOBJ:
  702.         case XLTYPE_CALLBACKOBJ:
  703.         case XLTYPE_PIXMAP_REFOBJ:
  704.                 case XLTYPE_EVHANDLEROBJ:
  705. #endif
  706.         case SYMBOL:
  707.         case OBJECT:
  708.         case VECTOR:
  709.         case CLOSURE:
  710.         case STRUCT:
  711.             if (p->n_vsize) {
  712.                 total -= (long) (p->n_vsize * sizeof(LVAL));
  713.                 free(p->n_vdata);
  714.             }
  715.             break;
  716.         }
  717.         p->n_type = FREE;
  718.         rplaca(p,NIL);
  719.         rplacd(p,fnodes);
  720.         fnodes = p;
  721.         nfree += 1L;
  722.         }
  723.         else
  724.         p->n_flags &= ~MARK;
  725.     }
  726. }
  727.  
  728. /* addseg - add a segment to the available memory */
  729. LOCAL int addseg()
  730. {
  731.     SEGMENT *newseg;
  732.     LVAL p;
  733.     int n;
  734.  
  735.     /* allocate the new segment */
  736.     if (anodes == 0 || (newseg = newsegment(anodes)) == NULL)
  737.     return (FALSE);
  738.  
  739.     /* add each new node to the free list */
  740.     p = &newseg->sg_nodes[0];
  741.     for (n = anodes; --n >= 0; ++p) {
  742.     rplacd(p,fnodes);
  743.     fnodes = p;
  744.     }
  745.  
  746.     /* return successfully */
  747.     return (TRUE);
  748. }
  749.  
  750. /* newsegment - create a new segment (only called here and in xlimage.c) */
  751. SEGMENT *newsegment(n)
  752.   int n;
  753. {
  754.     SEGMENT *newseg;
  755.  
  756.     /* allocate the new segment */
  757.     if ((newseg = (SEGMENT *)calloc(1,segsize(n))) == NULL)
  758.     return (NULL);
  759.  
  760.     /* initialize the new segment */
  761.     newseg->sg_size = n;
  762.     newseg->sg_next = NULL;
  763.     if (segs)
  764.     lastseg->sg_next = newseg;
  765.     else
  766.     segs = newseg;
  767.     lastseg = newseg;
  768.  
  769.     /* update the statistics */
  770.     total += (long)segsize(n);
  771.     nnodes += (long)n;
  772.     nfree += (long)n;
  773.     ++nsegs;
  774.  
  775.     /* return the new segment */
  776.     return (newseg);
  777. }
  778.  
  779. /* stats - print memory statistics */
  780. LOCAL stats()
  781. {
  782.     sprintf(buf,"Nodes:       %ld\n",nnodes); stdputstr(buf);
  783.     sprintf(buf,"Free nodes:  %ld\n",nfree);  stdputstr(buf);
  784.     sprintf(buf,"Segments:    %d\n",nsegs);   stdputstr(buf);
  785.     sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
  786.     sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
  787.     sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
  788. }
  789.  
  790. /* xgc - xlisp function to force garbage collection */
  791. LVAL xgc()
  792. {
  793.     /* make sure there aren't any arguments */
  794.     xllastarg();
  795.  
  796.     /* garbage collect */
  797.     gc();
  798.  
  799.     /* return nil */
  800.     return (NIL);
  801. }
  802.  
  803. /* xexpand - xlisp function to force memory expansion */
  804. LVAL xexpand()
  805. {
  806.     LVAL num;
  807.     int n,i;
  808.  
  809.     /* get the new number to allocate */
  810.     if (moreargs()) {
  811.     num = xlgafixnum();
  812.     n = getfixnum(num);
  813.     }
  814.     else
  815.     n = 1;
  816.     xllastarg();
  817.  
  818.     /* allocate more segments */
  819.     for (i = 0; i < n; i++)
  820.     if (!addseg())
  821.         break;
  822.  
  823.     /* return the number of segments added */
  824.     return (cvfixnum((FIXTYPE)i));
  825. }
  826.  
  827. /* xalloc - xlisp function to set the number of nodes to allocate */
  828. LVAL xalloc()
  829. {
  830.     int n,oldn;
  831.     LVAL num;
  832.  
  833.     /* get the new number to allocate */
  834.     num = xlgafixnum();
  835.     n = getfixnum(num);
  836.  
  837.     /* make sure there aren't any more arguments */
  838.     xllastarg();
  839.  
  840.     /* set the new number of nodes to allocate */
  841.     oldn = anodes;
  842.     anodes = n;
  843.  
  844.     /* return the old number */
  845.     return (cvfixnum((FIXTYPE)oldn));
  846. }
  847.  
  848. /* xmem - xlisp function to print memory statistics */
  849. LVAL xmem()
  850. {
  851.     /* allow one argument for compatiblity with common lisp */
  852.     if (moreargs()) xlgetarg();
  853.     xllastarg();
  854.  
  855.     /* print the statistics */
  856.     stats();
  857.  
  858.     /* return nil */
  859.     return (NIL);
  860. }
  861.  
  862. #ifdef SAVERESTORE
  863. /* xsave - save the memory image */
  864. LVAL xsave()
  865. {
  866.     unsigned char *name;
  867.  
  868.     /* get the file name, verbose flag and print flag */
  869.     name = getstring(xlgetfname());
  870.     xllastarg();
  871.  
  872.     /* save the memory image */
  873.     return (xlisave(name) ? true : NIL);
  874. }
  875.  
  876. /* xrestore - restore a saved memory image */
  877. LVAL xrestore()
  878. {
  879.     extern jmp_buf top_level;
  880.     unsigned char *name;
  881.  
  882.     /* get the file name, verbose flag and print flag */
  883.     name = getstring(xlgetfname());
  884.     xllastarg();
  885.  
  886.     /* restore the saved memory image */
  887.     if (!xlirestore(name))
  888.     return (NIL);
  889.  
  890.     /* return directly to the top level */
  891.     stdputstr("[ returning to the top level ]\n");
  892.     longjmp(top_level,1);
  893. }
  894. #endif
  895.  
  896. /* xlminit - initialize the dynamic memory module */
  897. xlminit()
  898. {
  899.     LVAL p;
  900.     int i;
  901.  
  902.     /* initialize our internal variables */
  903.     segs = lastseg = NULL;
  904.     nnodes = nfree = total = 0L;
  905.     nsegs = gccalls = 0;
  906.     anodes = NNODES;
  907.     fnodes = NIL;
  908.  
  909.     /* allocate the fixnum segment */
  910.     if ((fixseg = newsegment(SFIXSIZE)) == NULL)
  911.     xlfatal("insufficient memory");
  912.  
  913.     /* initialize the fixnum segment */
  914.     p = &fixseg->sg_nodes[0];
  915.     for (i = SFIXMIN; i <= SFIXMAX; ++i) {
  916.     p->n_type = FIXNUM;
  917.     p->n_fixnum = i;
  918.     ++p;
  919.     }
  920.  
  921.     /* allocate the character segment */
  922.     if ((charseg = newsegment(CHARSIZE)) == NULL)
  923.     xlfatal("insufficient memory");
  924.  
  925.     /* initialize the character segment */
  926.     p = &charseg->sg_nodes[0];
  927.     for (i = CHARMIN; i <= CHARMAX; ++i) {
  928.     p->n_type = CHAR;
  929.     p->n_chcode = i;
  930.     ++p;
  931.     }
  932.  
  933.     /* initialize structures that are marked by the collector */
  934.     obarray = xlenv = xlfenv = xldenv = NIL;
  935.     s_gcflag = s_gchook = NIL;
  936. #ifdef WINTERP
  937.     v_savedobjs = NIL;
  938. #endif
  939.  
  940.     /* allocate the evaluation stack */
  941.     if ((xlstkbase = (LVAL **)malloc(EDEPTH * sizeof(LVAL *))) == NULL)
  942.     xlfatal("insufficient memory");
  943.     xlstack = xlstktop = xlstkbase + EDEPTH;
  944.  
  945.     /* allocate the argument stack */
  946.     if ((xlargstkbase = (LVAL *)malloc(ADEPTH * sizeof(LVAL))) == NULL)
  947.     xlfatal("insufficient memory");
  948.     xlargstktop = xlargstkbase + ADEPTH;
  949.     xlfp = xlsp = xlargstkbase;
  950.     *xlsp++ = NIL;
  951. }
  952.  
  953.